home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / weak_table.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  3.8 KB  |  118 lines
  1. (herald weak_table
  2.   (env tsys (osys table) (osys table_entry)))
  3.  
  4. ;;;
  5. ;;;  Weak Tables
  6. ;;;
  7.  
  8. ;;;  MAKE-WEAK-TABLE
  9. ;;;  MAKE-WEAK-TABLE-OF-SIZE
  10. ;;;  MAKE-WEAK-HASH-TABLE
  11. ;;;  MAKE-WEAK-HASH-TABLE-OF-SIZE
  12. ;;;  WEAK-TABLE?
  13. ;;;  WEAK-TABLE-ENTRY
  14.  
  15. ; Not done yet
  16. ;;;  WEAK-TABLE-WALK
  17. ;;;  WALK-WEAK-TABLE
  18. ;;;  FIND-WEAK-TABLE-ENTRY
  19. ;;;  COPY-WEAK-TABLE
  20. ;;;  CLEAN-WEAK-TABLE
  21. ;;;  RETURN-WEAK-TABLE-TO-POOL
  22.  
  23. ;;; A weak table has:
  24. ;;;
  25. ;;; -1 Header
  26. ;;;  0 table     ; A %TABLE
  27. ;;;  1 vector    ;
  28.  
  29. ;;; ID should be gotten from the TABLE
  30.  
  31. ;;; HEADER/WEAK-TABLE should have the semaphore set!  This is important.
  32.  
  33. ;;; This should be elsewhere
  34. (define (%make-weak-table)
  35.   (make-vector-extend header/weak-table 0 2))
  36.  
  37. (define (create-weak-table start-size type hash comparison gc-sensitive? id)
  38.   (let ((table (create-%table id
  39.                               start-size
  40.                               gc-sensitive?
  41.                               type
  42.                               hash
  43.                               comparison))
  44.         (new (%make-weak-table)))
  45.     (set (weak-table-table  new) table)
  46. ;    (set (weak-table-vector new) (%table-vector table))
  47. ;    (set (%table-vector table) nil)
  48.     (set (weak-table-vector new) nil)
  49.     (clear-weak-semaphore new)
  50.     new))
  51.  
  52. (define (make-weak-hash-table type hash comparison gc-sensitive? . maybe-id)
  53.   (let ((type       (enforce procedure? type))
  54.         (hash       (enforce procedure? hash))
  55.         (comparison (enforce procedure? comparison))
  56.         (id (if (null? maybe-id) nil (car maybe-id))))
  57.     (create-weak-table 0 type hash comparison gc-sensitive? id)))
  58.  
  59. (define (make-weak-hash-table-of-size start-size type hash
  60.                                       comparison gc-sensitive? . maybe-id)
  61.   (let ((start-size (enforce nonnegative-fixnum? start-size))
  62.         (type       (enforce procedure? type))
  63.         (hash       (enforce procedure? hash))
  64.         (comparison (enforce procedure? comparison))
  65.         (id (if (null? maybe-id) nil (car maybe-id))))
  66.     (create-weak-table start-size type hash comparison gc-sensitive? id)))
  67.  
  68. (define (make-weak-table . maybe-id)
  69.   (create-weak-table 0 true descriptor-hash eq? t 
  70.                      (if (null? maybe-id) nil (car maybe-id))))
  71.  
  72. ;(define-integrable (weak-table-exchange table)
  73. ;  (exchange (weak-table-vector table)
  74. ;            (%table-vector (weak-table-table table))))
  75.  
  76. ;(define-integrable (set-table-semaphore table)
  77. ;  (set-weak-semaphore table))
  78. ;  (weak-table-exchange table))
  79.  
  80. ;(define-integrable (clear-table-semaphore table)
  81. ;  (weak-table-exchange table)
  82. ;  (clear-weak-semaphore table))
  83.  
  84. (define weak-table-entry
  85.   (object (lambda (table key)
  86.             (let* ((already-set? (test-and-set-semaphore table))
  87.                    (value (table-entry (weak-table-table table) key)))
  88.               (if (not already-set?) (clear-weak-semaphore table))
  89.               value))
  90.     ((setter self) set-weak-table-entry)))
  91.  
  92. (define (set-weak-table-entry table key val)
  93.   (let ((already-set? (test-and-set-semaphore table)))
  94.     (set (table-entry (weak-table-table table) key) val)
  95.     (if (not already-set?) (clear-weak-semaphore table))
  96.     (return)))
  97.  
  98. (define (find-weak-table-entry table test)
  99.   (let ((already-set? (test-and-set-semaphore table)))
  100.     (receive (key value)
  101.              (find-table-entry (weak-table-table table) test)
  102.       (if (not already-set?) (clear-weak-semaphore table))
  103.       (return key value))))
  104.  
  105. (define-handler weak-table
  106.   (object nil
  107.     ((print self stream)
  108.      (format stream "#{Weak-table~_~S}" (weak-table-table self)))
  109.     ((crawl-exhibit self)
  110.      (exhibit-standard-extend self 2 0 0))
  111.     ((maybe-crawl-component self command)
  112.      (cond ((and (nonnegative-fixnum? command)
  113.                  (fx< command 2))
  114.             (crawl-push (extend-pointer-elt self command)))
  115.            (else nil)))
  116.     ((identification self)
  117.      (identification (weak-table-table self)))))
  118.